home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / HOOKS.C < prev    next >
C/C++ Source or Header  |  1992-02-08  |  25KB  |  751 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/users/cph/src/microcode/RCS/hooks.c,v 9.44 1992/02/08 14:54:04 cph Exp $
  4.  
  5. Copyright (c) 1988-92 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* This file contains various hooks and handles that connect the
  36.    primitives with the main interpreter. */
  37.  
  38. #include "scheme.h"
  39. #include "prims.h"
  40. #include "winder.h"
  41. #include "history.h"
  42.  
  43. DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0)
  44. {
  45.   SCHEME_OBJECT procedure;
  46.   SCHEME_OBJECT argument_list;
  47.   fast long number_of_args;
  48. #ifdef LOSING_PARALLEL_PROCESSOR
  49.   SCHEME_OBJECT * saved_stack_pointer;
  50. #endif
  51.   PRIMITIVE_HEADER (2);
  52.   procedure = (ARG_REF (1));
  53.   argument_list = (ARG_REF (2));
  54.   /* Since this primitive must pop its own frame off and push a new
  55.      frame on the stack, it has to be careful.  Its own stack frame is
  56.      needed if an error or GC is required.  So these checks are done
  57.      first (at the cost of traversing the argument list twice), then
  58.      the primitive's frame is popped, and finally the new frame is
  59.      constructed.
  60.  
  61.      Originally this code tried to be clever by copying the argument
  62.      list into a linear (vector-like) form, so as to avoid the
  63.      overhead of traversing the list twice.  Unfortunately, the
  64.      overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
  65.      is sufficiently high that it probably makes up for the time saved. */
  66.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  67.   {
  68.     fast SCHEME_OBJECT scan_list;
  69.     TOUCH_IN_PRIMITIVE (argument_list, scan_list);
  70.     number_of_args = 0;
  71.     while (PAIR_P (scan_list))
  72.       {
  73.     number_of_args += 1;
  74.     TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  75.       }
  76.     if (scan_list != EMPTY_LIST)
  77.       error_wrong_type_arg (2);
  78.   }
  79. #ifdef USE_STACKLETS
  80.   /* This is conservative: if the number of arguments is large enough
  81.      the Will_Push below may try to allocate space on the heap for the
  82.      stack frame. */
  83.   Primitive_GC_If_Needed
  84.     (New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
  85. #endif
  86.   POP_PRIMITIVE_FRAME (2);
  87.  Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
  88. #ifdef LOSING_PARALLEL_PROCESSOR
  89.   saved_stack_pointer = Stack_Pointer;
  90. #endif
  91.   {
  92.     fast long i;
  93.     fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
  94.     fast SCHEME_OBJECT scan_list;
  95.     Stack_Pointer = scan_stack;
  96.     TOUCH_IN_PRIMITIVE (argument_list, scan_list);
  97.     for (i = number_of_args; (i > 0); i -= 1)
  98.       {
  99. #ifdef LOSING_PARALLEL_PROCESSOR
  100.     /* This half-measure should be replaced by some kind of lock
  101.        or something else that guarantees that the code will win.  */
  102.     /* Check for abominable case of someone bashing the arg list. */
  103.     if (! (PAIR_P (scan_list)))
  104.       {
  105.         Stack_Pointer = saved_stack_pointer;
  106.         error_bad_range_arg (2);
  107.       }
  108. #endif
  109.     (*scan_stack++) = (PAIR_CAR (scan_list));
  110.     TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  111.       }
  112.   }
  113.   STACK_PUSH (procedure);
  114.   STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
  115.  Pushed ();
  116.   PRIMITIVE_ABORT (PRIM_APPLY);
  117.   /*NOTREACHED*/
  118. }
  119.  
  120. /* Implementation detail: in addition to setting aside the old
  121.    stacklet on a catch, the new stacklet is cleared and a return
  122.    code is placed at the base of the (now clear) stack indicating
  123.    that a return back through here requires restoring the stacklet.
  124.    The current enabled interrupts are also saved in the old stacklet.
  125.  
  126.    >>> Temporarily (maybe) the act of doing a CATCH will disable any
  127.    >>> return hook that may be in the stack. */
  128.  
  129. #define CWCC(return_code, reuse_flag, receiver_expression)        \
  130. {                                    \
  131.   SCHEME_OBJECT receiver = (receiver_expression);            \
  132.   CWCC_1 ();                                \
  133.   POP_PRIMITIVE_FRAME (1);                        \
  134.   if (Return_Hook_Address != NULL)                    \
  135.     {                                    \
  136.       (* Return_Hook_Address) = Old_Return_Code;            \
  137.       Return_Hook_Address = NULL;                    \
  138.     }                                    \
  139.   /* Put down frames to restore history and interrupts so that these    \
  140.      operations will be performed on a throw. */            \
  141.  Will_Push (HISTORY_SIZE);                        \
  142.   Save_History (return_code);                        \
  143.  Pushed ();                                \
  144.   preserve_interrupt_mask ();                        \
  145.   /* There is no history to use since the                \
  146.      last control point was formed. */                    \
  147.   Prev_Restore_History_Stacklet = NULL;                    \
  148.   Prev_Restore_History_Offset = 0;                    \
  149.   {                                    \
  150.     SCHEME_OBJECT control_point;                    \
  151.     CWCC_2 (control_point, reuse_flag);                    \
  152.     /* we just cleared the stack so there MUST be room */        \
  153.     /* Will_Push(3); */                            \
  154.     STACK_PUSH (control_point);                        \
  155.     STACK_PUSH (receiver);                        \
  156.     STACK_PUSH (STACK_FRAME_HEADER + 1);                \
  157.     /*  Pushed(); */                            \
  158.   }                                    \
  159. }
  160.  
  161. #ifdef USE_STACKLETS
  162.  
  163. #define CWCC_1()                            \
  164. {                                    \
  165.   Primitive_GC_If_Needed (2 * Default_Stacklet_Size);            \
  166. }
  167.  
  168. #define CWCC_2(target, reuse_flag)                    \
  169. {                                    \
  170.   (target) = (Get_Current_Stacklet ());                    \
  171.   Allocate_New_Stacklet (3);                        \
  172. }
  173.  
  174. #else /* not USE_STACKLETS */
  175.  
  176. #define CWCC_1()                            \
  177. {                                    \
  178.   Primitive_GC_If_Needed                        \
  179.     ((Stack_Top - Stack_Pointer) +                    \
  180.      STACKLET_HEADER_SIZE +                        \
  181.      CONTINUATION_SIZE +                        \
  182.      HISTORY_SIZE);                            \
  183. }
  184.  
  185. #define CWCC_2(target, reuse_flag)                    \
  186. {                                    \
  187.   fast long n_words = (Stack_Top - Stack_Pointer);            \
  188.   (target) =                                \
  189.     (allocate_marked_vector                        \
  190.      (TC_CONTROL_POINT,                            \
  191.       (n_words + (STACKLET_HEADER_SIZE - 1)),                \
  192.       false));                                \
  193.   FAST_MEMORY_SET ((target), STACKLET_REUSE_FLAG, (reuse_flag));    \
  194.   FAST_MEMORY_SET                            \
  195.     ((target),                                \
  196.      STACKLET_UNUSED_LENGTH,                        \
  197.      (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)));                \
  198.   {                                    \
  199.     fast SCHEME_OBJECT * scan =                        \
  200.       (MEMORY_LOC ((target), STACKLET_HEADER_SIZE));            \
  201.     while ((n_words--) > 0)                        \
  202.       (*scan++) = (STACK_POP ());                    \
  203.   }                                    \
  204.   if (Consistency_Check && (Stack_Pointer != Stack_Top))        \
  205.     Microcode_Termination (TERM_BAD_STACK);                \
  206.  Will_Push (CONTINUATION_SIZE);                        \
  207.   Store_Return (RC_JOIN_STACKLETS);                    \
  208.   Store_Expression (target);                        \
  209.   Save_Cont ();                                \
  210.  Pushed ();                                \
  211. }
  212.  
  213. #endif /* USE_STACKLETS */
  214.  
  215. /* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE)
  216.  
  217.    Creates a control point (a pointer to the current stack) and passes
  218.    it to PROCEDURE as its only argument.  The inverse operation,
  219.    typically called THROW, is performed by using the control point as
  220.    you would a procedure.  A control point accepts one argument which
  221.    is then returned as the value of the CATCH which created the
  222.    control point.  If the reuse flag of the stacklet is clear then the
  223.    control point may be reused as often as desired since the stack
  224.    will be copied on every throw.  The user level CATCH is built on
  225.    this primitive but is not the same, since it handles dynamic state
  226.    while the primitive does not; it assumes that the microcode sets
  227.    and clears the appropriate reuse flags for copying. */
  228.  
  229. DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION", Prim_catch, 1, 1, 0)
  230. {
  231.   PRIMITIVE_HEADER (1);
  232.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  233.   CWCC (RC_RESTORE_HISTORY, SHARP_F, (ARG_REF (1)));
  234.   PRIMITIVE_ABORT (PRIM_APPLY);
  235.   /*NOTREACHED*/
  236. }
  237.  
  238. DEFINE_PRIMITIVE ("NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", Prim_non_reentrant_catch, 1, 1, 0)
  239. {
  240.   PRIMITIVE_HEADER (1);
  241.   PRIMITIVE_CANONICALIZE_CONTEXT();
  242. #ifdef USE_STACKLETS
  243.   CWCC (RC_RESTORE_DONT_COPY_HISTORY, SHARP_T, (ARG_REF (1)));
  244. #else
  245.   /* When there are no stacklets, it is identical to the reentrant version. */
  246.   CWCC (RC_RESTORE_HISTORY, SHARP_F, (ARG_REF (1)));
  247. #endif
  248.   PRIMITIVE_ABORT (PRIM_APPLY);
  249.   /*NOTREACHED*/
  250. }
  251.  
  252. DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2, 0)
  253. {
  254.   PRIMITIVE_HEADER (2);
  255.   PRIMITIVE_CANONICALIZE_CONTEXT();
  256.   CHECK_ARG (1, CONTROL_POINT_P);
  257.   {
  258.     fast SCHEME_OBJECT control_point = (ARG_REF (1));
  259.     SCHEME_OBJECT thunk = (ARG_REF (2));
  260.     Our_Throw (false, control_point);
  261.     Within_Stacklet_Backout ();
  262.     Our_Throw_Part_2 ();
  263.   Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  264.     STACK_PUSH (thunk);
  265.     STACK_PUSH (STACK_FRAME_HEADER);
  266.   Pushed ();
  267.   }
  268.   PRIMITIVE_ABORT (PRIM_APPLY);
  269.   /*NOTREACHED*/
  270. }
  271.  
  272. DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3, 0)
  273. {
  274.   PRIMITIVE_HEADER (3);
  275.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  276.   {
  277.     fast SCHEME_OBJECT message = (ARG_REF (1));
  278.     fast SCHEME_OBJECT irritants = (ARG_REF (2));
  279.     fast SCHEME_OBJECT environment = (ARG_REF (3));
  280.     /* This is done outside the Will_Push because the space for it
  281.        is guaranteed by the interpreter before it gets here.
  282.        If done inside, this could break when using stacklets. */
  283.     back_out_of_primitive ();
  284.   Will_Push (HISTORY_SIZE + STACK_ENV_EXTRA_SLOTS + 4);
  285.     Stop_History ();
  286.     /* Stepping should be cleared here! */
  287.     STACK_PUSH (environment);
  288.     STACK_PUSH (irritants);
  289.     STACK_PUSH (message);
  290.     STACK_PUSH (Get_Fixed_Obj_Slot (Error_Procedure));
  291.     STACK_PUSH (STACK_FRAME_HEADER + 3);
  292.   Pushed ();
  293.     PRIMITIVE_ABORT (PRIM_APPLY);
  294.     /*NOTREACHED*/
  295.   }
  296. }
  297.  
  298. DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2, 0)
  299. {
  300.   PRIMITIVE_HEADER (2);
  301.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  302.   CHECK_ARG (2, ENVIRONMENT_P);
  303.   {
  304.     fast SCHEME_OBJECT expression = (ARG_REF (1));
  305.     fast SCHEME_OBJECT environment = (ARG_REF (2));
  306.     POP_PRIMITIVE_FRAME (2);
  307.     Store_Env (environment);
  308.     Store_Expression (expression);
  309.   }
  310.   PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
  311.   /*NOTREACHED*/
  312. }
  313.  
  314. DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1, 0)
  315. {
  316.   PRIMITIVE_HEADER (1);
  317.   CHECK_ARG (1, PROMISE_P);
  318.   {
  319.     fast SCHEME_OBJECT thunk = (ARG_REF (1));
  320.     fast SCHEME_OBJECT State = (MEMORY_REF (thunk, THUNK_SNAPPED));
  321.     if (State == SHARP_T)
  322.       PRIMITIVE_RETURN (MEMORY_REF (thunk, THUNK_VALUE));
  323.     else if (State ==  FIXNUM_ZERO)
  324.     {
  325.       /* New-style thunk used by compiled code. */
  326.       PRIMITIVE_CANONICALIZE_CONTEXT();
  327.       POP_PRIMITIVE_FRAME (1);
  328.      Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
  329.       Store_Return (RC_SNAP_NEED_THUNK);
  330.       Store_Expression (thunk);
  331.       Save_Cont ();
  332.       STACK_PUSH (MEMORY_REF (thunk, THUNK_VALUE));
  333.       STACK_PUSH (STACK_FRAME_HEADER);
  334.      Pushed ();
  335.       PRIMITIVE_ABORT (PRIM_APPLY);
  336.       /*NOTREACHED*/
  337.     }
  338.     else
  339.     {
  340.       /* Old-style thunk used by interpreted code. */
  341.       PRIMITIVE_CANONICALIZE_CONTEXT();
  342.       POP_PRIMITIVE_FRAME (1);
  343.      Will_Push (CONTINUATION_SIZE);
  344.       Store_Return (RC_SNAP_NEED_THUNK);
  345.       Store_Expression (thunk);
  346.       Save_Cont ();
  347.      Pushed ();
  348.       Store_Env (FAST_MEMORY_REF (thunk, THUNK_ENVIRONMENT));
  349.       Store_Expression (FAST_MEMORY_REF (thunk, THUNK_PROCEDURE));
  350.       PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
  351.       /*NOTREACHED*/
  352.     }
  353.   }
  354. }
  355.  
  356. /* State Space Implementation */
  357.  
  358. DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT", Prim_execute_at_new_point, 4, 4, 0)
  359. {
  360.   PRIMITIVE_HEADER (4);
  361.  
  362.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  363.   guarantee_state_point ();
  364.   {
  365.     SCHEME_OBJECT old_point;
  366.     if ((ARG_REF (1)) == SHARP_F)
  367.       old_point = Current_State_Point;
  368.     else
  369.       {
  370.     CHECK_ARG (1, STATE_SPACE_P);
  371.     old_point =
  372.       (FAST_MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
  373.       }
  374.     {
  375.       SCHEME_OBJECT new_point =
  376.     (allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
  377.       SCHEME_OBJECT during_thunk = (ARG_REF (3));
  378.       FAST_MEMORY_SET
  379.     (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
  380.       FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, (ARG_REF (2)));
  381.       FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, (ARG_REF (4)));
  382.       FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, old_point);
  383.       FAST_MEMORY_SET
  384.     (new_point,
  385.      STATE_POINT_DISTANCE_TO_ROOT,
  386.      (1 + (FAST_MEMORY_REF (old_point, STATE_POINT_DISTANCE_TO_ROOT))));
  387.  
  388.       POP_PRIMITIVE_FRAME (4);
  389.     Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 1));
  390.       /* Push a continuation to go back to the current state after the
  391.      body is evaluated */
  392.       Store_Expression (old_point);
  393.       Store_Return (RC_RESTORE_TO_STATE_POINT);
  394.       Save_Cont ();
  395.       /* Push a stack frame which will call the body after we have moved
  396.      into the new state point */
  397.       STACK_PUSH (during_thunk);
  398.       STACK_PUSH (STACK_FRAME_HEADER);
  399.       /* Push the continuation to go with the stack frame */
  400.       Store_Expression (SHARP_F);
  401.       Store_Return (RC_INTERNAL_APPLY);
  402.       Save_Cont ();
  403.     Pushed ();
  404.       Translate_To_Point (new_point);
  405.       /*NOTREACHED*/
  406.     }
  407.   }
  408. }
  409.  
  410. DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1, 0)
  411. {
  412.   PRIMITIVE_HEADER (1);
  413.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  414.   CHECK_ARG (1, STATE_POINT_P);
  415.   {
  416.     SCHEME_OBJECT state_point = (ARG_REF (1));
  417.     POP_PRIMITIVE_FRAME (1);
  418.     Translate_To_Point (state_point);
  419.     /*NOTREACHED*/
  420.   }
  421. }
  422.  
  423. DEFINE_PRIMITIVE ("MAKE-STATE-SPACE", Prim_make_state_space, 1, 1,
  424.   "Return a newly-allocated state-space.\n\
  425. Argument MUTABLE?, if not #F, means return a mutable state-space.\n\
  426. Otherwise, -the- immutable state-space is saved internally.")
  427. {
  428.   PRIMITIVE_HEADER (1);
  429.   {
  430.     fast SCHEME_OBJECT new_point =
  431.       (allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
  432.     FAST_MEMORY_SET
  433.       (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
  434.     FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, SHARP_F);
  435.     FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, SHARP_F);
  436.     FAST_MEMORY_SET
  437.       (new_point, STATE_POINT_DISTANCE_TO_ROOT, (LONG_TO_UNSIGNED_FIXNUM (0)));
  438.     if ((ARG_REF (1)) == SHARP_F)
  439.       {
  440.     FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, SHARP_F);
  441.     Current_State_Point = new_point;
  442.     PRIMITIVE_RETURN (SHARP_F);
  443.       }
  444.     else
  445.       {
  446.     fast SCHEME_OBJECT new_space =
  447.       (allocate_marked_vector (TC_VECTOR, STATE_SPACE_LENGTH, true));
  448.     FAST_MEMORY_SET
  449.       (new_space, STATE_SPACE_TAG, (Get_Fixed_Obj_Slot (State_Space_Tag)));
  450.     FAST_MEMORY_SET (new_space, STATE_SPACE_NEAREST_POINT, new_point);
  451.     FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, new_space);
  452.     PRIMITIVE_RETURN (new_space);
  453.       }
  454.   }
  455. }
  456.  
  457. DEFINE_PRIMITIVE ("CURRENT-DYNAMIC-STATE", Prim_current_dynamic_state, 1, 1, 0)
  458. {
  459.   PRIMITIVE_HEADER (1);
  460.  
  461.   guarantee_state_point ();
  462.   if ((ARG_REF (1)) == SHARP_F)
  463.     PRIMITIVE_RETURN (Current_State_Point);
  464.   CHECK_ARG (1, STATE_SPACE_P);
  465.   PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
  466. }
  467.  
  468. DEFINE_PRIMITIVE ("SET-CURRENT-DYNAMIC-STATE!", Prim_set_dynamic_state, 1, 1, 0)
  469. {
  470.   PRIMITIVE_HEADER (1);
  471.   CHECK_ARG (1, STATE_POINT_P);
  472.   {
  473.     fast SCHEME_OBJECT state_point = (ARG_REF (1));
  474.     fast SCHEME_OBJECT state_space = (Find_State_Space (state_point));
  475.     fast SCHEME_OBJECT result;
  476.     if (state_space == SHARP_F)
  477.       {
  478.     guarantee_state_point ();
  479.     result = Current_State_Point;
  480.     Current_State_Point = state_point;
  481.       }
  482.     else
  483.       {
  484.     result = (MEMORY_REF (state_space, STATE_SPACE_NEAREST_POINT));
  485.     MEMORY_SET (state_space, STATE_SPACE_NEAREST_POINT, state_point);
  486.       }
  487.     PRIMITIVE_RETURN (result);
  488.   }
  489. }
  490.  
  491. /* Interrupts */
  492.  
  493. DEFINE_PRIMITIVE ("GET-INTERRUPT-ENABLES", Prim_get_interrupt_enables, 0, 0,
  494.   "Returns the current interrupt mask.")
  495. {
  496.   PRIMITIVE_HEADER (0);
  497.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (FETCH_INTERRUPT_MASK ()));
  498. }
  499.  
  500. DEFINE_PRIMITIVE ("SET-INTERRUPT-ENABLES!", Prim_set_interrupt_enables, 1, 1,
  501.   "Sets the interrupt mask to NEW-INT-ENABLES; returns previous mask value.\n\
  502. See `mask_interrupt_enables' for more information on interrupts.")
  503. {
  504.   PRIMITIVE_HEADER (1);
  505.   {
  506.     long previous = (FETCH_INTERRUPT_MASK ());
  507.     SET_INTERRUPT_MASK ((arg_integer (1)) & INT_Mask);
  508.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (previous));
  509.   }
  510. }
  511.  
  512. DEFINE_PRIMITIVE ("CLEAR-INTERRUPTS!", Prim_clear_interrupts, 1, 1,
  513.   "Clears the interrupt bits in the MASK argument.\n\
  514. The bits in MASK are interpreted as for `get-interrupt-enables'.")
  515. {
  516.   PRIMITIVE_HEADER (1);
  517.   CLEAR_INTERRUPT ((arg_integer (1)) & INT_Mask);
  518.   PRIMITIVE_RETURN (UNSPECIFIC);
  519. }
  520.  
  521. DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1, 0)
  522. {
  523.   PRIMITIVE_HEADER (1);
  524.   {
  525.     fast long previous = (FETCH_INTERRUPT_MASK ());
  526.     SET_INTERRUPT_MASK (previous &~ ((arg_integer (1)) & INT_Mask));
  527.     PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
  528.   }
  529. }
  530.  
  531. DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1, 0)
  532. {
  533.   PRIMITIVE_HEADER (1);
  534.   {
  535.     fast long previous = (FETCH_INTERRUPT_MASK ());
  536.     SET_INTERRUPT_MASK (previous | ((arg_integer (1)) & INT_Mask));
  537.     PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
  538.   }
  539. }
  540.  
  541. DEFINE_PRIMITIVE ("RETURN-TO-APPLICATION", Prim_return_to_application, 2, LEXPR,
  542.   "Invokes first argument THUNK with no arguments and a special return address.\n\
  543. The return address calls the second argument on the remaining arguments.\n\
  544. This is used by the runtime system to create stack frames that can be\n\
  545. identified by the continuation parser.")
  546. {
  547.   PRIMITIVE_HEADER (LEXPR);
  548.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  549.   {
  550.     long nargs = (LEXPR_N_ARGUMENTS ());
  551.     if (nargs < 2)
  552.       signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  553.     {
  554.       SCHEME_OBJECT thunk = (STACK_POP ());
  555.       STACK_PUSH (STACK_FRAME_HEADER + (nargs - 2));
  556.       Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN));
  557.       Store_Expression (SHARP_F);
  558.       Store_Return (RC_INTERNAL_APPLY);
  559.       Save_Cont ();
  560.     Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  561.       STACK_PUSH (thunk);
  562.       STACK_PUSH (STACK_FRAME_HEADER);
  563.     Pushed ();
  564.     }
  565.   }
  566.   PRIMITIVE_ABORT (PRIM_APPLY);
  567.   /*NOTREACHED*/
  568. }
  569.  
  570. DEFINE_PRIMITIVE ("WITH-STACK-MARKER", Prim_with_stack_marker, 3, 3,
  571.   "Call first argument THUNK with a continuation that has a special marker.\n\
  572. When THUNK returns, the marker is discarded.\n\
  573. The value of THUNK is returned to the continuation of this primitive.\n\
  574. The marker consists of the second and third arguments.\n\
  575. By convention, the second argument is a tag identifying the kind of marker,\n\
  576. and the third argument is data identifying the marker instance.")
  577. {
  578.   PRIMITIVE_HEADER (3);
  579.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  580.   {
  581.     SCHEME_OBJECT thunk = (STACK_POP ());
  582.     STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, RC_STACK_MARKER));
  583.   Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  584.     STACK_PUSH (thunk);
  585.     STACK_PUSH (STACK_FRAME_HEADER);
  586.   Pushed ();
  587.   }
  588.   PRIMITIVE_ABORT (PRIM_APPLY);
  589.   /*NOTREACHED*/
  590. }
  591.  
  592. DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, 0)
  593. {
  594.   PRIMITIVE_HEADER (2);
  595.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  596.   {
  597.     long new_mask = (INT_Mask & (arg_integer (1)));
  598.     SCHEME_OBJECT thunk = (ARG_REF (2));
  599.     POP_PRIMITIVE_FRAME (2);
  600.     preserve_interrupt_mask ();
  601.   Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  602.     STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
  603.     STACK_PUSH (thunk);
  604.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  605.   Pushed ();
  606.     SET_INTERRUPT_MASK (new_mask);
  607.     PRIMITIVE_ABORT (PRIM_APPLY);
  608.     /*NOTREACHED*/
  609.   }
  610. }
  611.  
  612. DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED", Prim_with_interrupts_reduced, 2, 2, 0)
  613. {
  614.   PRIMITIVE_HEADER (2);
  615.   PRIMITIVE_CANONICALIZE_CONTEXT();
  616.   {
  617.     long new_mask = (INT_Mask & (arg_integer (1)));
  618.     long old_mask = (FETCH_INTERRUPT_MASK ());
  619.     SCHEME_OBJECT thunk = (ARG_REF (2));
  620.     POP_PRIMITIVE_FRAME (2);
  621.     preserve_interrupt_mask ();
  622.   Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  623.     STACK_PUSH (LONG_TO_FIXNUM (old_mask));
  624.     STACK_PUSH (thunk);
  625.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  626.   Pushed ();
  627.     SET_INTERRUPT_MASK
  628.       ((new_mask > old_mask) ? new_mask : (new_mask & old_mask));
  629.     PRIMITIVE_ABORT (PRIM_APPLY);
  630.     /*NOTREACHED*/
  631.   }
  632. }
  633.  
  634. /* History */
  635.  
  636. SCHEME_OBJECT
  637. initialize_history ()
  638. {
  639.   /* Dummy History Structure */
  640.   History = (Make_Dummy_History ());
  641.   return
  642.     (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, (Make_Dummy_History ())));
  643. }
  644.  
  645. DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1, 0)
  646. {
  647.   PRIMITIVE_HEADER (1);
  648.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  649.   CHECK_ARG (1, HUNK3_P);
  650.   Val = (*History);
  651. #ifndef DISABLE_HISTORY
  652.   History = (OBJECT_ADDRESS (ARG_REF (1)));
  653. #else
  654.   History = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
  655. #endif
  656.   POP_PRIMITIVE_FRAME (1);
  657.   PRIMITIVE_ABORT (PRIM_POP_RETURN);
  658.   /*NOTREACHED*/
  659. }
  660.  
  661. DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1, 0)
  662. {
  663.   PRIMITIVE_HEADER (1);
  664.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  665.   {
  666.     SCHEME_OBJECT thunk = (ARG_REF (1));
  667.     /* Remove one reduction from the history before saving it */
  668.     SCHEME_OBJECT * first_rib = (OBJECT_ADDRESS (History [HIST_RIB]));
  669.     SCHEME_OBJECT * second_rib =
  670.       (OBJECT_ADDRESS (first_rib [RIB_NEXT_REDUCTION]));
  671.     if ((first_rib != second_rib) &&
  672.     (! (HISTORY_MARKED_P (first_rib [RIB_MARK]))))
  673.       {
  674.     HISTORY_MARK (second_rib [RIB_MARK]);
  675.     {
  676.       SCHEME_OBJECT * rib = first_rib;
  677.       while (1)
  678.         {
  679.           fast SCHEME_OBJECT * next_rib =
  680.         (OBJECT_ADDRESS (rib [RIB_NEXT_REDUCTION]));
  681.           if (next_rib == first_rib)
  682.         break;
  683.           rib = next_rib;
  684.         }
  685.       /* This maintains the mark in (History [HIST_RIB]). */
  686.       (History [HIST_RIB]) =
  687.         (MAKE_POINTER_OBJECT ((OBJECT_TYPE (History [HIST_RIB])), rib));
  688.     }
  689.       }
  690.     POP_PRIMITIVE_FRAME (1);
  691.     Stop_History ();
  692.   Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  693.     STACK_PUSH (thunk);
  694.     STACK_PUSH (STACK_FRAME_HEADER);
  695.   Pushed ();
  696.     PRIMITIVE_ABORT (PRIM_APPLY);
  697.     /*NOTREACHED*/
  698.   }
  699. }
  700.  
  701. /* Miscellaneous State */
  702.  
  703. DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0, 0)
  704. {
  705.   PRIMITIVE_HEADER (0);
  706.   PRIMITIVE_RETURN (Fluid_Bindings);
  707. }
  708.  
  709. DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1, 0)
  710. {
  711.   PRIMITIVE_HEADER (1);
  712.   CHECK_ARG (1, APPARENT_LIST_P);
  713.   {
  714.     SCHEME_OBJECT old_bindings = Fluid_Bindings;
  715.     Fluid_Bindings = (ARG_REF (1));
  716.     PRIMITIVE_RETURN (old_bindings);
  717.   }
  718. }
  719.  
  720. DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR", Prim_get_fixed_objects_vector, 0, 0, 0)
  721. {
  722.   PRIMITIVE_HEADER (0);
  723.   if (Valid_Fixed_Obj_Vector ())
  724.     PRIMITIVE_RETURN (Get_Fixed_Obj_Slot (Me_Myself));
  725.   PRIMITIVE_RETURN (SHARP_F);
  726. }
  727.  
  728. #ifndef SET_FIXED_OBJ_HOOK
  729. #define SET_FIXED_OBJ_HOOK(vector) Fixed_Objects = (vector)
  730. #endif
  731.  
  732. DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!", Prim_set_fixed_objects_vector, 1, 1, 0)
  733. {
  734.   PRIMITIVE_HEADER (1);
  735.   CHECK_ARG (1, VECTOR_P);
  736.   {
  737.     fast SCHEME_OBJECT vector = (ARG_REF (1));
  738.     if ((VECTOR_LENGTH (vector)) < NFixed_Objects)
  739.       error_bad_range_arg (1);
  740.     {
  741.       SCHEME_OBJECT result =
  742.     ((Valid_Fixed_Obj_Vector ())
  743.      ? (Get_Fixed_Obj_Slot (Me_Myself))
  744.      : SHARP_F);
  745.       SET_FIXED_OBJ_HOOK (vector);
  746.       Set_Fixed_Obj_Slot (Me_Myself, vector);
  747.       PRIMITIVE_RETURN (result);
  748.     }
  749.   }
  750. }
  751.